/*M*  MUNGE_SI6   PL6 source for Adventure munger */
MUNGE: PROC MAIN;
 
%INCLUDE CP_6;
%INCLUDE CP_6_SUBS;
%INCLUDE B_ERRORS_C;
%INCLUDE ADVENTURE_C61;
%INCLUDE XU_MACRO_C;
%INCLUDE XU_SUBS_C;
%INCLUDE B$JIT;
 
%XUU_PARAM (FPTN=XUU_OPEN,
            BASE=YES,
            UPDATE=NO);
 
%XUU_PARAM (FPTN=XUU_READ,
            BLANK_FILL=YES,
            SOURCE_OUT=NO);
 
%XUU_PARAM (FPTN=XUU_CLOSE,
            CLOSE_ALL=YES);
 
%P_PCB  (NAME=P_PCB,
         T=SOURCE.LINE,
         W=PARSE_WORK,
         WSZ="SIZEW(PARSE_WORK)",
         C_LD=' {',
         C_TL=' }');
 
%PARSE$OUT (NAME=OUT$BLK,
            STCLASS="BASED(P_PCB.OUT$)");
 
%PARSE$SYM (NAME=OUT$SYM,
            STCLASS=BASED);
 
%FPT_OPEN  (FPTN=OPEN_DATABASE,
            DCB=M$OU,
            ORG=KEYED,
            ACS=DIRECT,
            FUN=CREATE,
            DISP=NAMED,
            EXIST=NEWFILE,
            TYPE='I ',
            IXTNSIZE=100,
            XTNSIZE=100);
 
%FPT_OPEN  (FPTN=OPEN_LO,
            DCB=M$LO,
            FUN=CREATE);
 
%FPT_WRITE (FPTN=WRITE_TEXT,
            DCB=M$OU,
            SEED=%SEED,
            KEY=FILE_KEY,
            NEWKEY=YES);
 
%FPT_WRITE (FPTN=WRITE_INST,
            DCB=M$OU,
            SEED=%SEED,
            KEY=FILE_KEY,
            NEWKEY=YES);
 
%FPT_WRITE (FPTN=WRITE_MISC,
            DCB=M$OU,
            SEED=%SEED,
            KEY=FILE_KEY,
            NEWKEY=YES);
 
%FPT_DEVICE   (FPTN=EJECT_LO,
               DCB=M$LO,
               PAGE=YES);
 
%FPT_WRITE (FPTN=WRITE_LO,
            DCB=M$LO,
            BUF=SOURCE);
 
%FPT_CLOSE (FPTN=CLOSE_DATABASE,
            DCB=M$OU,
            DISP=SAVE,
            RELG=YES);
 
%FPT_CLOSE (FPTN=CLOSE_LO,
            DCB=M$LO,
            DISP=SAVE);
 
%FPT_ERRMSG (CODE=YUKK,
             OUTDCB1=M$LO,
             RESULTS=VLR_ERRMSG,
             BUF=WHIMPER,
             SUBMESS=YES);
 
%FPT_GDS   (FPTN=GET_VOCAB_DATA,
            SEGSIZE=1024,
            RESULTS=VOCAB_AREA);
 
%FPT_INT   (UENTRY=BREAK_HIT);
 
%FPT_TRMPRG   (FPTN=RESET_BREAK,
               RSTBRK=YES);
 
%VLP_VECTOR   (FPTN=VOCAB_AREA,
               SEGID='0'O);
 
%VLR_ERRMSG;
 
%F$DCB;
%B$TCB (STCLASS="BASED(B$TCB$)");
%B$EXCFR;
%B$ALT;
 
DCL BREAK_KEY BIT(1) STATIC SYMDEF INIT (%NO#);
 
DCL SYMNAME CHAR (12) STATIC ALIGNED;
 
DCL 1 SYMASCII REDEF SYMNAME,
   2 WORD1 UBIN,
   2 WORD2 UBIN,
   2 WORD3 UBIN;
 
DCL LOC SBIN;
DCL OWNER SBIN;
 
DCL FIRST_CHAR UBIN;
DCL ARS UBIN;
 
DCL FLUSHED LOGICAL;
 
DCL YUKK BIT(36) STATIC;
 
DCL PROCESS_MODE UBIN WORD STATIC INIT (%NIL_MODE);
 
DCL 1 SOURCE STATIC,
   2 ASCII_KEY CHAR (10),
   2 SEP CHAR (1) INIT (' '),
   2 LINE CHAR (140);
 
DCL WHIMPER CHAR (120) STATIC;
 
DCL READ_VECTOR BIT (72) DALIGNED CONSTANT INIT (VECTOR(SOURCE.LINE));
 
DCL S_TABLE (0:127) UBIN BYTE UNAL STATIC INIT (%TEXT_LINE * 0);
 
DCL 1 SYMTAB (0:%SYMSIZE) STATIC,
   2 NAME CHAR (12),
   2 VALUE SBIN,
   2 NEXT_TEXT UBIN,
   2 NEXT_INST UBIN,
   2 FLAGS,
      3 DEFINED LOGICAL,
      3 USED LOGICAL,
      3 PRIMARY LOGICAL,
      3 * BIT (29);
 
DCL PARSE_WORK (0:499) UBIN STATIC;
 
DCL 1 FILE_KEY STATIC,
   2 LEN UBIN BYTE UNAL INIT (3),
   2 KEY UBIN (27) UNAL;
 
DCL 1 HEADER_RECORD STATIC,
      2 VOCAB_SIZE UBIN INIT (0),
      2 MAX_BUF_ENTRIES UBIN INIT (0),
      2 NUMBER_OF_OBJECTS UBIN,
      2 NUMBER_OF_PLACES UBIN,
      2 NUMBER_OF_VARIABLES UBIN;
 
DCL VOCAB$ PTR;
 
DCL 1 VOCAB_ENTRY BASED (VOCAB$) UNAL,
      2 PREFIX CHAR (1),
      2 VALUE UBIN HALF UNAL,
      2 INFIX CHAR (1),
      2 NAME CHAR (12);
 
DCL VOCAB_SPACE UBIN STATIC INIT (0);
 
DCL INST_BUF (0:499) UBIN HALF UNAL;
DCL BUF_LEN UBIN STATIC INIT (0);
 
DCL MAJOR_COMMANDS BIT (36) SYMREF;
DCL MINOR_COMMANDS BIT (36) SYMREF;
 
DCL NEXT_INITIAL UBIN STATIC INIT (%(INITIAL_TYPE * 1000));
DCL NEXT_TEXT UBIN STATIC INIT (%(TEXT_TYPE * 1000));
DCL NEXT_PLACE UBIN STATIC INIT (%(PLACE_TYPE * 1000));
DCL NEXT_OBJECT UBIN STATIC INIT (%(OBJECT_TYPE * 1000));
DCL NEXT_LABEL UBIN STATIC INIT (%(LABEL_TYPE * 1000));
DCL NEXT_VERB UBIN STATIC INIT (%(VERB_TYPE * 1000));
DCL NEXT_NULLWORD UBIN STATIC INIT (%(NULLWORD_TYPE * 1000));
DCL NEXT_REPEAT UBIN STATIC INIT (%(REPEAT_TYPE * 1000));
DCL NEXT_VARIABLE UBIN STATIC INIT (%(VARIABLE_TYPE * 1000));
 
DCL M$LO DCB;
DCL M$OU DCB;
DCL M$SI DCB;
DCL M$UI DCB;
 
DCL B$JIT$ PTR SYMREF;
DCL B$TCB$ PTR SYMREF;
 
DCL XUU$OPEN ENTRY (1) ALTRET;
DCL XUU$READ ENTRY (2) ALTRET;
DCL XUU$CLOSE ENTRY (1) ALTRET;
 
DCL X$PARSE ENTRY (1) ALTRET;
 
DCL BREAK_HIT ENTRY ASYNC;
 
%EJECT;
INITIALIZE: PROC;
 
DCL I UBIN;
 
   CALL M$OPEN (OPEN_LO) ALTRET (M$OPEN_BLETCH);
 
   XUU_OPEN.FLAGS.UP_DATE# = B$JIT.PRFLAGS.UI;
 
   CALL XUU$OPEN (XUU_OPEN) ALTRET (XUU_OPEN_BLETCH);
 
   DO NEVER;
 
XUU_OPEN_BLETCH:
 
      IF XUU_OPEN.SI_ERRCODE ~= '0'B
        THEN DO;
 
         YUKK = XUU_OPEN.SI_ERRCODE;
         FPT_ERRMSG.V.DCB# = DCBNUM(M$SI);
         END;
 
        ELSE DO;
 
         YUKK = XUU_OPEN.UI_ERRCODE;
         FPT_ERRMSG.V.DCB# = DCBNUM(M$UI);
         END;
 
      CALL M$ERRMSG (FPT_ERRMSG);
      CALL M$ERR;
 
      END;
 
   CALL M$OPEN (OPEN_DATABASE) ALTRET (M$OPEN_BLETCH);
 
   DO NEVER;
 
M$OPEN_BLETCH:
 
      CALL HANDLE_MONITOR_ERROR;
      END;
 
   WRITE_INST.BUF_ = VECTOR(INST_BUF);
 
   IF B$JIT.PRFLAGS.LIST
     THEN
      CALL M$DEVICE (EJECT_LO);
 
   S_TABLE(ASCBIN(' ')) = %BLANK_LINE;
   S_TABLE(ASCBIN('%')) = %PERCENT_LINE;
   S_TABLE(ASCBIN('/')) = %SLASH_LINE;
 
   DO I = 0 TO %SYMSIZE - 1;
 
      SYMTAB.NAME(I) = ' ';
 
      END;
 
   CALL M$INT (FPT_INT);
 
   RETURN;
 
END INITIALIZE;
 
 
HANDLE_MONITOR_ERROR: PROC;
 
   YUKK = B$TCB.ALT$ -> B$EXCFR.ERR;
   FPT_ERRMSG.V.DCB# = B$TCB.ALT$ -> B$ALT.DCB#;
 
   CALL M$ERRMSG (FPT_ERRMSG);
   CALL M$ERR;
 
END HANDLE_MONITOR_ERROR;
 
 
GRIPE: PROC (MESSAGE, CPOS);
 
DCL MESSAGE CHAR (120);
DCL 1 CPOS UNAL,
      2 PARTIAL,
         3 SECTION UBIN (14) UNAL,
         3 * BIT (22),
      2 ENTIRE REDEF PARTIAL UBIN WORD UNAL;
 
DCL REAL_CPOS SBIN;
DCL MESSAGE_LEN SBIN;
 
   CALL FLUSH;
 
   FLUSHED = %NO#;
 
   SOURCE.ASCII_KEY = ' ';
   SOURCE.LINE = ' ';
 
   CALL INDEX (MESSAGE_LEN, '!', MESSAGE);
 
   IF CPOS.PARTIAL.SECTION ~= 0
     THEN
      REAL_CPOS = CPOS.PARTIAL.SECTION;
     ELSE
      REAL_CPOS = CPOS.ENTIRE;
 
   IF REAL_CPOS > LENGTHC(SOURCE.LINE)
     THEN
      REAL_CPOS = ARS;
 
   IF MESSAGE_LEN > REAL_CPOS - 10
     THEN
      CALL INSERT (SOURCE.LINE, REAL_CPOS, , '^ ',
       SUBSTR(MESSAGE, 0, MESSAGE_LEN + 1));
     ELSE
      CALL INSERT (SOURCE.LINE, REAL_CPOS - MESSAGE_LEN - 3, ,
       SUBSTR(MESSAGE, 0, MESSAGE_LEN + 1), '  ^');
 
   CALL FLUSH;
 
   RETURN;
 
END GRIPE;
 
 
FLUSH: PROC;
 
   IF NOT FLUSHED
     THEN
      CALL M$WRITE (WRITE_LO);
 
   FLUSHED = %YES#;
 
   RETURN;
 
END FLUSH;
 
 
EVAL: PROC (NODE, N);
 
%PARSE$OUT (NAME=NODE, STCLASS=" ");
DCL N SBIN;
 
DCL P$ PTR;
DCL OP SBIN;
DCL I SBIN;
DCL J SBIN;
 
   N = 0;
 
   DO I = 0 TO NODE.NSUBLKS-1 BY 2;
 
      P$ = NODE.SUBLK$(I);
 
      OP = P$ -> OUT$BLK.CODE;
 
      IF P$ -> OUT$BLK.NDTYPE < %NULL#
        THEN
         P$ = P$ -> OUT$BLK.SUBLK$(0);
 
      DO CASE (OP);
 
       CASE (%DECIMAL);
         CALL CHARBIN (J, P$ -> OUT$SYM.TEXT);
 
       CASE (%NEG_DECIMAL);
         CALL CHARBIN (J, P$ -> OUT$SYM.TEXT);
         J = -J;
 
       CASE (%SYMBOL);
         SYMNAME = P$ -> OUT$SYM.TEXT;
         CALL LOCATE ALTRET (SKIP_IT);
         J = SYMTAB.VALUE(LOC);
 
       CASE (%@SYMBOL);
         SYMNAME = P$ -> OUT$SYM.TEXT;
         CALL LOCATE ALTRET (SKIP_IT);
         J = MOD(SYMTAB.NEXT_TEXT(LOC), 1000) / 10;
 
       END;
 
      IF I = 0
        THEN
         OP = %PLUS;
        ELSE
         OP = NODE.SUBLK$(I-1) -> OUT$BLK.CODE;
 
      DO CASE (OP);
 
       CASE (%PLUS); N = N + J;
       CASE (%MINUS); N = N - J;
       END;
 
      DO NEVER;
 
         SKIP_IT: CALL GRIPE ('Undefined symbol!', P$ -> OUT$BLK.CPOS);
 
         END;
 
      END /* do I */;
 
   RETURN;
 
END EVAL;
 
 
DEFINE: PROC (NODE, VAL) ALTRET;
 
%PARSE$SYM (NAME=NODE, STCLASS=" ");
DCL VAL UBIN;
 
   SYMNAME = NODE.TEXT;
 
   CALL LOCATE ALTRET (OK);
 
   CALL GRIPE ('Duplicate symbol!', NODE.CPOS);
 
   ALTRETURN;
 
OK:
   SYMTAB.NAME(LOC) = SYMNAME;
   SYMTAB.VALUE(LOC) = VAL;
   SYMTAB.NEXT_TEXT(LOC) = VAL * 1000;
   SYMTAB.NEXT_INST(LOC) = VAL * 1000 + 500;
   SYMTAB.FLAGS(LOC) = '0'B;
 
   RETURN;
 
END DEFINE;
 
 
LOCATE: PROC ALTRET;
 
DCL REHASH UBIN;
 
   LOC = SYMASCII.WORD1 + SYMASCII.WORD2 + SYMASCII.WORD3;
 
   IF LOC < 0
     THEN
      LOC = -LOC;
 
   REHASH = MOD(LOC, %SYMSIZE);
 
   IF REHASH = 0
     THEN
      REHASH = 185;
 
   LOC = REHASH;
 
   DO WHILE (SYMTAB.NAME(LOC) ~= ' ');
 
      IF SYMTAB.NAME(LOC) = SYMNAME
        THEN
         RETURN;
 
      LOC = MOD (LOC + REHASH, %SYMSIZE);
 
      END;
 
   ALTRETURN;
 
END LOCATE;
 
 
HANDLE_PARSE_ERROR: PROC;
 
DCL FAILURES (0:7) CHAR (15) CONSTANT INIT
      (  'Gaah!',
         'Syntax error!',
         'Null root!',
         'Bad node!',
         'WKSP overflow!',
         'WKSP too small!',
         'Gaah!',
         'Null U$$!' );
 
   CALL GRIPE (FAILURES(P_PCB.ERROR.CODE), P_PCB.HI_CHAR);
 
   RETURN;
 
END HANDLE_PARSE_ERROR;
 
 
TERMINATE_BUFFER: PROC;
 
   INST_BUF(BUF_LEN) = %END_OF_RECORD;
   BUF_LEN = BUF_LEN + 1;
 
   WRITE_INST.BUF_.BOUND = (BUF_LEN * 2) - 1;
 
   FILE_KEY.KEY = SYMTAB.NEXT_INST(OWNER);
 
   SYMTAB.NEXT_INST(OWNER) = FILE_KEY.KEY + 1;
 
   CALL M$WRITE (WRITE_INST) ALTRET (BLETCH);
 
   IF HEADER_RECORD.MAX_BUF_ENTRIES < BUF_LEN * 2
     THEN
      HEADER_RECORD.MAX_BUF_ENTRIES = BUF_LEN * 2;
 
   BUF_LEN = 0;
 
   RETURN;
 
BLETCH:
 
   CALL HANDLE_MONITOR_ERROR;
 
END TERMINATE_BUFFER;
 
 
PROCESS: PROC;
 
   IF SUBSTR(SOURCE.LINE, 0, 1) ~= '*'
     THEN
      IF SUBSTR(SOURCE.LINE, 0, 1) ~= ' '
        THEN
         CALL PROCESS_MAJOR_COMMAND;
        ELSE
         CALL PROCESS_MINOR_COMMAND;
 
   IF B$JIT.PRFLAGS.LIST
    OR BREAK_KEY
     THEN
      CALL FLUSH;
 
   IF BREAK_KEY
     THEN DO;
 
      BREAK_KEY = %NO#;
      CALL M$TRMPRG (RESET_BREAK);
      END;
 
   RETURN;
 
END PROCESS;
 
 
PROCESS_MINOR_COMMAND: PROC;
 
   DO CASE (PROCESS_MODE);
 
    CASE (%NIL_MODE);
    CASE (%TEXT_MODE);  CALL PROCESS_TEXT;
    CASE (%INST_MODE);  CALL PROCESS_INST;
    END;
 
   RETURN;
 
END PROCESS_MINOR_COMMAND;
 
 
PROCESS_TEXT: PROC;
 
DCL LINE_TYPE UBIN;
 
   CALL SEARCH (FIRST_CHAR, LINE_TYPE, S_TABLE, SOURCE.LINE);
 
   DO CASE (LINE_TYPE);
 
    CASE (%BLANK_LINE);
 
      FIRST_CHAR = 0;
      CALL WRITE_TEXT_RECORD;
 
    CASE (%TEXT_LINE);
 
      CALL WRITE_TEXT_RECORD;
 
    CASE (%PERCENT_LINE);
 
      SYMTAB.NEXT_TEXT(OWNER) = 10 * (1 + SYMTAB.NEXT_TEXT(OWNER) / 10);
      FIRST_CHAR = FIRST_CHAR + 1;
      CALL WRITE_TEXT_RECORD;
 
    CASE (%SLASH_LINE);
 
      FIRST_CHAR = FIRST_CHAR + 1;
      CALL WRITE_TEXT_RECORD;
 
    END;
 
   RETURN;
 
END PROCESS_TEXT;
 
 
PROCESS_INST: PROC;
 
DCL I SBIN;
DCL J SBIN;
 
DCL NSUBLKS UBIN;
 
   P_PCB.ROOT$ = ADDR(MINOR_COMMANDS);
 
   CALL X$PARSE (P_PCB) ALTRET (PARSE_ERROR);
 
   NSUBLKS = OUT$BLK.NSUBLKS;
 
   INST_BUF(BUF_LEN) = OUT$BLK.CODE;
 
   DO I = 0 TO NSUBLKS - 1;
 
      CALL EVAL (OUT$BLK.SUBLK$(I) -> OUT$BLK, J);
 
      INST_BUF(BUF_LEN + I + 1) = J;
 
      END;
 
   BUF_LEN = BUF_LEN + NSUBLKS + 1;
 
   RETURN;
 
PARSE_ERROR:
 
   CALL HANDLE_PARSE_ERROR;
 
   RETURN;
 
END PROCESS_INST;
 
 
WRITE_TEXT_RECORD: PROC;
 
   FILE_KEY.KEY = SYMTAB.NEXT_TEXT(OWNER);
 
   SYMTAB.NEXT_TEXT(OWNER) = FILE_KEY.KEY + 1;
 
   IF FIRST_CHAR >= ARS
     THEN
      WRITE_TEXT.BUF_ = VECTOR(NIL);
     ELSE
      WRITE_TEXT.BUF_ = VECTOR(SUBSTR(SOURCE.LINE, FIRST_CHAR,
       ARS - FIRST_CHAR));
 
   IF SUBSTR(SOURCE.LINE, FIRST_CHAR, 3) ~= '>$<'
    AND SUBSTR(SOURCE.LINE, FIRST_CHAR, 1) ~= '*'
    AND SUBSTR(SOURCE.LINE, FIRST_CHAR, 1) ~= '{'
     THEN
      CALL M$WRITE (WRITE_TEXT) ALTRET (BLETCH);
 
   RETURN;
 
BLETCH:
 
   CALL HANDLE_MONITOR_ERROR;
 
END WRITE_TEXT_RECORD;
 
 
PROCESS_MAJOR_COMMAND: PROC;
 
DCL I SBIN;
DCL J SBIN;
DCL NSUBLKS UBIN;
 
   DO CASE (PROCESS_MODE);
 
    CASE (%NIL_MODE);
    CASE (%TEXT_MODE);
    CASE (%INST_MODE); CALL TERMINATE_BUFFER;
    END;
 
   BUF_LEN = 0;
 
   PROCESS_MODE = %NIL_MODE;
 
   P_PCB.ROOT$ = ADDR(MAJOR_COMMANDS);
 
   CALL X$PARSE (P_PCB) ALTRET (PARSE_ERROR);
 
   NSUBLKS = OUT$BLK.NSUBLKS;
 
   DO CASE (OUT$BLK.CODE);
 
    CASE (%TEXT);
 
      IF NSUBLKS = 1
        THEN DO;
 
         CALL DEFINE (OUT$BLK.SUBLK$(0) -> OUT$SYM, NEXT_TEXT);
         OWNER = LOC;
         END;
 
        ELSE DO;
 
         OWNER = %SYMSIZE;
         SYMTAB.NEXT_TEXT(%SYMSIZE) = NEXT_TEXT * 1000;
         END;
 
      NEXT_TEXT = NEXT_TEXT + 1;
      PROCESS_MODE = %TEXT_MODE;
 
    CASE (%OBJECT);
 
      CALL DEFINE (OUT$BLK.SUBLK$(0) -> OUT$SYM, NEXT_OBJECT);
      NEXT_OBJECT = NEXT_OBJECT + 1;
      OWNER = LOC;
      PROCESS_MODE = %TEXT_MODE;
      SYMTAB.FLAGS.DEFINED(OWNER) = %YES#;
      SYMTAB.FLAGS.PRIMARY(OWNER) = %YES#;
 
    CASE (%PLACE);
 
      CALL DEFINE (OUT$BLK.SUBLK$(0) -> OUT$SYM, NEXT_PLACE);
      NEXT_PLACE = NEXT_PLACE + 1;
      OWNER = LOC;
      PROCESS_MODE = %TEXT_MODE;
      SYMTAB.FLAGS.PRIMARY(OWNER) = %YES#;
 
    CASE (%VERB);
 
      DO I = 0 TO NSUBLKS - 1;
 
         CALL DEFINE (OUT$BLK.SUBLK$(I) -> OUT$SYM, NEXT_VERB);
         SYMTAB.FLAGS.DEFINED(LOC) = %YES#;
 
         IF I = 0
           THEN DO;
 
            SYMTAB.FLAGS.PRIMARY(LOC) = %YES#;
            OWNER = LOC;
            END;
 
         END;
 
      NEXT_VERB = NEXT_VERB + 1;
 
    CASE (%INITIAL);
 
      OWNER = %SYMSIZE;
      SYMTAB.NEXT_INST(%SYMSIZE) = (NEXT_INITIAL * 1000) + 500;
      NEXT_INITIAL = NEXT_INITIAL + 1;
      PROCESS_MODE = %INST_MODE;
 
    CASE (%LABEL);
 
      CALL DEFINE (OUT$BLK.SUBLK$(0) -> OUT$SYM, NEXT_LABEL);
      NEXT_LABEL = NEXT_LABEL + 1;
      PROCESS_MODE = %INST_MODE;
      OWNER = LOC;
 
    CASE (%REPEAT);
 
      OWNER = %SYMSIZE;
      SYMTAB.NEXT_INST(%SYMSIZE) = (NEXT_REPEAT * 1000) + 500;
      NEXT_REPEAT = NEXT_REPEAT + 1;
      PROCESS_MODE = %INST_MODE;
 
    CASE (%AT_CMD);
 
      CALL EVAL (OUT$BLK.SUBLK$(0) -> OUT$BLK, I);
 
      IF (I / 1000) ~= %PLACE_TYPE
        THEN
         CALL GRIPE ('That''s no place!', 0);
 
        ELSE DO;
 
         OWNER = LOC;
         PROCESS_MODE = %INST_MODE;
         END;
 
    CASE (%ACTION);
 
      CALL EVAL (OUT$BLK.SUBLK$(0) -> OUT$BLK, I);
 
      OWNER = LOC;
 
      IF NSUBLKS > 1
        THEN DO;
 
         DO I = 1 TO NSUBLKS - 1;
 
            CALL EVAL (OUT$BLK.SUBLK$(I) -> OUT$BLK, J);
 
            INST_BUF(BUF_LEN) = %KEYWORD_OP;
            INST_BUF(BUF_LEN + 1) = J;
            BUF_LEN = BUF_LEN + 2;
 
            END;
 
         END;
 
      PROCESS_MODE = %INST_MODE;
 
    CASE (%SYNONYM);
 
      CALL EVAL (OUT$BLK.SUBLK$(0) -> OUT$SYM, I);
 
      OWNER = LOC;
 
      DO J = 1 TO NSUBLKS - 1;
 
         CALL DEFINE (OUT$BLK.SUBLK$(J) -> OUT$SYM, I);
         SYMTAB.FLAGS.DEFINED(LOC) = SYMTAB.FLAGS.DEFINED(OWNER);
         END;
 
    CASE (%VARIABLE);
 
      DO I = 0 TO NSUBLKS - 1;
 
         CALL DEFINE (OUT$BLK.SUBLK$(I) -> OUT$SYM, NEXT_VARIABLE);
         NEXT_VARIABLE = NEXT_VARIABLE + 1;
         END;
 
    CASE (%NULLWORD);
 
      DO I = 0 TO NSUBLKS - 1;
 
         CALL DEFINE (OUT$BLK.SUBLK$(I) -> OUT$SYM, NEXT_NULLWORD);
         SYMTAB.FLAGS.DEFINED(LOC) = %YES#;
         NEXT_NULLWORD = NEXT_NULLWORD + 1;
         END;
 
    CASE (%DEFINE);
 
      DO I = 0 TO NSUBLKS - 1;
 
         CALL EVAL (OUT$BLK.SUBLK$(I) -> OUT$BLK, J);
         SYMTAB.FLAGS.DEFINED(LOC) = %YES#;
         END;
 
    END;
 
   RETURN;
 
PARSE_ERROR:
 
   CALL HANDLE_PARSE_ERROR;
 
   RETURN;
 
END PROCESS_MAJOR_COMMAND;
 
 
READIN: PROC ALTRET;
 
DCL OOPS LOGICAL;
 
   OOPS = %NO#;
 
   CALL XUU$READ (XUU_READ, READ_VECTOR) ALTRET (EOF_ENCOUNTERED);
 
   DO NEVER;
 
EOF_ENCOUNTERED:
 
      IF XUU_READ.ERRCODE.ERR# = %E$EOF
        THEN
         ALTRETURN;
 
      YUKK = XUU_READ.ERRCODE;
      FPT_ERRMSG.V.DCB# = B$TCB.ALT$ -> B$ALT.DCB#;
      OOPS = %YES#;
 
      END;
 
   ARS = XUU_READ.ARS;
 
   P_PCB.NCHARS = ARS;
   FLUSHED = %NO#;
   SOURCE.ASCII_KEY = XUU_READ.ASCII_KEY;
 
   IF OOPS
     THEN DO;
 
      SOURCE.SEP = '?';
      CALL FLUSH;
      CALL M$ERRMSG (FPT_ERRMSG);
      CALL M$ERR;
      END;
 
   RETURN;
 
END READIN;
 
 
DIG_THE_CAVE: PROC;
 
   DO FOREVER;
 
      CALL READIN ALTRET (EOF_ENCOUNTERED);
 
      CALL PROCESS;
 
      END;
 
EOF_ENCOUNTERED:
 
   RETURN;
 
END DIG_THE_CAVE;
 
 
WRITE_SYMBOL_TABLE: PROC;
 
DCL I UBIN;
 
   HEADER_RECORD.NUMBER_OF_OBJECTS = MOD(NEXT_OBJECT, 1000);
   HEADER_RECORD.NUMBER_OF_PLACES = MOD(NEXT_PLACE, 1000);
   HEADER_RECORD.NUMBER_OF_VARIABLES = MOD(NEXT_VARIABLE, 1000);
 
   DO I = 0 TO %SYMSIZE;
 
      IF SYMTAB.NAME(I) ~= ' '
       AND SYMTAB.FLAGS.DEFINED(I)
        THEN
         CALL EMIT_WORD(I);
 
      END;
 
   VOCAB_ENTRY.PREFIX = '@';
   HEADER_RECORD.VOCAB_SIZE = HEADER_RECORD.VOCAB_SIZE + 1;
 
   WRITE_MISC.BUF_.BOUND = HEADER_RECORD.VOCAB_SIZE - 1;
   FILE_KEY.KEY = (%HEADER_TYPE * 1000 + 1) * 1000;
 
   CALL M$WRITE (WRITE_MISC) ALTRET (BLETCH);
 
   WRITE_MISC.BUF_ = VECTOR(HEADER_RECORD);
   FILE_KEY.KEY = (%HEADER_TYPE * 1000) * 1000;
 
   CALL M$WRITE (WRITE_MISC) ALTRET (BLETCH);
 
   RETURN;
 
BLETCH:
 
   CALL HANDLE_MONITOR_ERROR;
 
END WRITE_SYMBOL_TABLE;
 
 
EMIT_WORD: PROC (I);
 
DCL I UBIN;
DCL J UBIN;
 
   IF VOCAB_SPACE <= SIZEC(VOCAB_ENTRY)
     THEN DO;
 
      CALL M$GDS (GET_VOCAB_DATA) ALTRET (BLETCH);
 
      IF HEADER_RECORD.VOCAB_SIZE = 0
        THEN DO;
 
         VOCAB$ = VOCAB_AREA.PTR$;
         WRITE_MISC.BUF_.BUF$ = VOCAB$;
         END;
 
      VOCAB_SPACE = VOCAB_SPACE + (GET_VOCAB_DATA.V.SEGSIZE# * 4);
 
      END;
 
   IF SYMTAB.FLAGS.PRIMARY(I)
     THEN
      VOCAB_ENTRY.PREFIX = '$';
     ELSE
      VOCAB_ENTRY.PREFIX = '@';
 
   VOCAB_ENTRY.VALUE = SYMTAB.VALUE(I);
   VOCAB_ENTRY.INFIX = '/';
   VOCAB_ENTRY.NAME = SYMTAB.NAME(I);
 
   CALL INDEX (J, ' ', VOCAB_ENTRY.NAME) ALTRET (FULL_TWELVE);
 
   DO NEVER;
      FULL_TWELVE: J = 12;
      END;
 
   J = J + SIZEC(VOCAB_ENTRY) - SIZEC(VOCAB_ENTRY.NAME);
 
   VOCAB_SPACE = VOCAB_SPACE - J;
   HEADER_RECORD.VOCAB_SIZE = HEADER_RECORD.VOCAB_SIZE + J;
   VOCAB$ = PINCRC(VOCAB$, J);
 
   RETURN;
 
BLETCH:
 
   CALL HANDLE_MONITOR_ERROR;
 
END EMIT_WORD;
 
 
SHUT_DOWN: PROC;
 
   IF PROCESS_MODE = %INST_MODE
     THEN
      IF BUF_LEN > 0
        THEN
         CALL TERMINATE_BUFFER;
 
   CALL WRITE_SYMBOL_TABLE;
 
   CALL XUU$CLOSE (XUU_CLOSE);
 
   CALL M$CLOSE (CLOSE_DATABASE) ALTRET (BLETCH);
 
   CALL M$CLOSE (CLOSE_LO) ALTRET (BLETCH);
 
   RETURN;
 
BLETCH:
 
   CALL HANDLE_MONITOR_ERROR;
 
   RETURN;
 
END SHUT_DOWN;
 
 
   CALL INITIALIZE;
 
   CALL DIG_THE_CAVE;
 
   CALL SHUT_DOWN;
 
   CALL M$EXIT;
 
 
 
END MUNGE;
%EOD;
BREAK_HIT: PROC ASYNC;
 
%INCLUDE CP_6_SUBS;
 
DCL BREAK_KEY BIT (1) SYMREF;
 
   BREAK_KEY = %YES#;
 
   RETURN;
 
END BREAK_HIT;